home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE05 / PERFORM / DIROUTLN.PAS next >
Encoding:
Pascal/Delphi Source File  |  1995-07-24  |  11.1 KB  |  397 lines
  1. unit DirOutln;
  2. { Directory outline component }
  3.  
  4. interface
  5.  
  6. uses Classes, Forms, Controls, Outline, SysUtils, Graphics,
  7.      Grids, StdCtrls, Menus;
  8.  
  9. type
  10.   TTextCase = (tcLowerCase, tcUpperCase, tcAsIs);
  11.   TCaseFunction = function(const AString: string): string;
  12.  
  13.   TDirectoryOutline = class(TCustomOutline)
  14.   private
  15.     FDrive: Char;
  16.     FDirectory: TFileName;
  17.     FOnChange: TNotifyEvent;
  18.     FTextCase: TTextCase;
  19.     FCaseFunction: TCaseFunction;
  20.   protected
  21.     procedure SetDrive(NewDrive: Char);
  22.     procedure SetDirectory(const NewDirectory: TFileName);
  23.     procedure SetTextCase(NewTextCase: TTextCase);
  24.     procedure AssignCaseProc;
  25.     procedure BuildOneLevel(RootItem: Longint); virtual;
  26.     procedure BuildTree; virtual;
  27.     procedure BuildSubTree(RootItem: Longint); virtual;
  28.     procedure Change; virtual;
  29.     procedure Click; override;
  30.     procedure CreateWnd; override;
  31.     procedure Expand(Index: Longint); override;
  32.     procedure Loaded; override;
  33.     procedure WalkTree(const Dest: string);
  34.   public
  35.     constructor Create(AOwner: TComponent); override;
  36.     function ForceCase(const AString: string): string;
  37.     property Drive: Char  read FDrive write SetDrive;
  38.     property Directory: TFileName  read FDirectory write SetDirectory;
  39.   published
  40.     property Align;
  41.   { property Lines stored False; }
  42.   { property Options default [ooStretchBitmaps, ooDrawFocusRect]; }
  43.     property BorderStyle;
  44.     property Color;
  45.     property Ctl3D;
  46.     property DragCursor;
  47.     property DragMode;
  48.     property Enabled;
  49.     property Font;
  50.     property ItemHeight;
  51.     property OnChange: TNotifyEvent  read FOnChange write FOnChange;
  52.     property OnClick;
  53.     property OnCollapse;
  54.     property OnDblClick;
  55.     property OnDragDrop;
  56.     property OnDragOver;
  57.     property OnDrawItem;
  58.     property OnEndDrag;
  59.     property OnEnter;
  60.     property OnExit;
  61.     property OnExpand;
  62.     property OnKeyDown;
  63.     property OnKeyPress;
  64.     property OnKeyUp;
  65.     property OnMouseDown;
  66.     property OnMouseMove;
  67.     property OnMouseUp;
  68.     property Options default [ooStretchBitmaps, ooDrawFocusRect];
  69.     property ParentColor;
  70.     property ParentCtl3D;
  71.     property ParentFont;
  72.     property ParentShowHint;
  73.     property PictureClosed;
  74.     property PictureLeaf;
  75.     property PictureOpen;
  76.     property PopupMenu;
  77.     property ScrollBars;
  78.     property Style;
  79.     property ShowHint;
  80.     property TabOrder;
  81.     property TabStop;
  82.     property TextCase: TTextCase  read FTextCase write SetTextCase default tcLowerCase;
  83.     property Visible;
  84.   end;
  85.  
  86. function SameLetter(Letter1, Letter2: Char): Boolean;
  87.  
  88. procedure Register;
  89.  
  90. implementation
  91. {.$DEFINE PROFILE}
  92. {$DEFINE DRBOB}
  93.  
  94. {$IFDEF PROFILE}
  95. Uses Dialogs;
  96. function timeGetTime: LongInt; far; external 'MMSYSTEM' index 607;
  97. {$ENDIF}
  98.  
  99. const
  100.   InvalidIndex = -1;
  101.  
  102. procedure Register;
  103. begin
  104.   RegisterComponents('Samples', [TDirectoryOutline]);
  105. end;
  106.  
  107. constructor TDirectoryOutline.Create(AOwner: TComponent);
  108. begin
  109.   inherited Create(AOwner);
  110.   PictureLeaf := PictureClosed;
  111.   Options := [ooStretchBitmaps, ooDrawFocusRect];
  112.   TextCase := tcLowerCase;
  113.   AssignCaseProc;
  114. end;
  115.  
  116. procedure TDirectoryOutline.AssignCaseProc;
  117. begin
  118.   case TextCase of
  119.     tcLowerCase: FCaseFunction := AnsiLowerCase;
  120.     tcUpperCase: FCaseFunction := AnsiUpperCase;
  121.     else FCaseFunction := nil;
  122.   end;
  123. end;
  124.  
  125. type
  126.   PNodeInfo = ^TNodeInfo;
  127.   TNodeInfo = record
  128.     RootName: TFileName;
  129.     SearchRec: TSearchRec;
  130.     DosError: Integer;
  131.     RootNode: TOutlineNode;
  132.     TempChild, NewChild: Longint;
  133.   end;
  134.  
  135.  
  136. procedure TDirectoryOutline.BuildOneLevel(RootItem: Longint);
  137. var
  138.   NodeInfo: PNodeInfo;
  139. {$IFDEF PROFILE}
  140.   Time: LongInt;
  141.   Str: String;
  142. {$ENDIF}
  143.  
  144. {$IFDEF DRBOB}
  145.   function FindIndex(RootNode: TOutLineNode; SearchName: TFileName): LongInt;
  146.   { speed-up by Dr. Bob: use Binary Search! }
  147.   var FirstChild,LastChild,TempChild: LongInt;
  148.   begin
  149.     FirstChild := RootNode.GetFirstChild;
  150.     if (FirstChild = InvalidIndex) or
  151.        (SearchName <= Items[FirstChild].Text) then FindIndex := FirstChild
  152.     else
  153.     begin
  154.       LastChild := RootNode.GetLastChild;
  155.       if SearchName >= Items[LastChild].Text then FindIndex := InvalidIndex {!}
  156.       else
  157.       begin
  158.         repeat
  159.           TempChild := (FirstChild + LastChild) div 2; { binary search }
  160.           if TempChild = FirstChild then Inc(TempChild);
  161.           if SearchName > Items[TempChild].Text then FirstChild := TempChild
  162.                                                 else LastChild := TempChild
  163.         until FirstChild >= (LastChild-1);
  164.         FindIndex := LastChild
  165.       end
  166.     end
  167.   end {FindIndex};
  168. {$ENDIF}
  169.  
  170. begin
  171.   {$IFDEF PROFILE}
  172.   Time := timeGetTime;
  173.   {$ENDIF}
  174.   New(NodeInfo);
  175.   try
  176.     with NodeInfo^ do
  177.     begin
  178.       RootName := Items[RootItem].FullPath;
  179.       if RootName[Length(RootName)] <> '\' then
  180.         RootName := Concat(RootName, '\');
  181.       RootName := Concat(RootName, '*.*');
  182.       RootNode := Items[RootItem]; { Dr. Bob: moved out of the while loop }
  183.       DosError := FindFirst(RootName, faDirectory, SearchRec);
  184.       while DosError = 0 do
  185.       begin
  186.         if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
  187.         begin
  188.           SearchRec.Name := ForceCase(SearchRec.Name);
  189.           if RootNode.HasItems then { if has children, must alphabetize }
  190.           begin
  191.             {$IFNDEF DRBOB}
  192.             { Dr. Bottle-neck: Lineair Search applied: }
  193.             TempChild := RootNode.GetFirstChild;
  194.             while (TempChild <> InvalidIndex) and (Items[TempChild].Text < SearchRec.Name) do
  195.               TempChild := RootNode.GetNextChild(TempChild);
  196.             {$ELSE}
  197.             TempChild := FindIndex(RootNode, SearchRec.Name); { Dr. Bob }
  198.             {$ENDIF}
  199.             if TempChild <> InvalidIndex then
  200.               NewChild := Insert(TempChild, SearchRec.Name)
  201.             else NewChild := Add(RootNode.GetLastChild, SearchRec.Name);
  202.           end
  203.           else NewChild := AddChild(RootItem, SearchRec.Name); { if first child, just add }
  204.         end;
  205.         DosError := FindNext(SearchRec);
  206.       end;
  207.     end;
  208.     Items[RootItem].Data := Pointer(1); { make non-nil so we know we've been here }
  209.   finally
  210.   {$IFDEF PROFILE}
  211.     Time := timeGetTime - Time;
  212.     FmtStr(Str,'%s Time: %d',[NodeInfo^.RootName,Time]);
  213.     MessageDlg(Str,mtInformation,[mbOK],0);
  214.   {$ENDIF}
  215.     Dispose(NodeInfo);
  216.   end;
  217. end;
  218.  
  219. procedure TDirectoryOutline.BuildTree;
  220. var
  221.   RootNode: Longint;
  222. begin
  223.   Clear;
  224.   RootNode := AddChild(0, ForceCase(Drive + ':'));
  225.   WalkTree(FDirectory);
  226.   Change;
  227. end;
  228.  
  229. procedure TDirectoryOutline.BuildSubTree(RootItem: Longint);
  230. var
  231.   TempRoot: Longint;
  232.   RootNode: TOutlineNode;
  233. begin
  234.   BuildOneLevel(RootItem);
  235.   RootNode := Items[RootItem];
  236.   TempRoot := RootNode.GetFirstChild;
  237.   while TempRoot <> InvalidIndex do
  238.   begin
  239.     BuildSubTree(TempRoot);
  240.     TempRoot := RootNode.GetNextChild(TempRoot);
  241.   end;
  242. end;
  243.  
  244. procedure TDirectoryOutline.Change;
  245. begin
  246.   if Assigned(FOnChange) then FOnChange(Self);
  247. end;
  248.  
  249. procedure TDirectoryOutline.Click;
  250. begin
  251.   inherited Click;
  252.   Directory := Items[SelectedItem].FullPath;
  253. end;
  254.  
  255. procedure TDirectoryOutline.CreateWnd;
  256. var
  257.   CurrentPath: TFileName;
  258. begin
  259.   inherited CreateWnd;
  260.   if FDrive = #0 then
  261.   begin
  262.     GetDir(0, CurrentPath);
  263.     FDrive := ForceCase(CurrentPath)[1];
  264.     FDirectory := ForceCase(CurrentPath);
  265.   end;
  266.   if not (csLoading in ComponentState) then BuildTree;
  267. end;
  268.  
  269. procedure TDirectoryOutline.Expand(Index: Longint);
  270. begin
  271.   if Items[Index].Data = nil then { if we've not previously expanded }
  272.     BuildOneLevel(Index);
  273.   inherited Expand(Index); { call the event handler }
  274. end;
  275.  
  276. function TDirectoryOutline.ForceCase(const AString: string): string;
  277. begin
  278.   if Assigned(FCaseFunction) then
  279.     Result := FCaseFunction(AString)
  280.   else Result := AString;
  281. end;
  282.  
  283. procedure TDirectoryOutline.Loaded;
  284. begin
  285.   inherited Loaded;
  286.   AssignCaseProc;
  287.   BuildTree;
  288. end;
  289.  
  290. procedure TDirectoryOutline.SetDirectory(const NewDirectory: TFileName);
  291. var
  292.   TempPath: TFileName;
  293. begin
  294.   if Length(NewDirectory) > 0 then  { ignore empty directory }
  295.   begin
  296.     TempPath := ForceCase(ExpandFileName(NewDirectory)); { expand to full path }
  297.     if (Length(TempPath) > 3) and (TempPath[Length(TempPath)] = '\') then
  298.       TempPath[0] := Char(Length(TempPath) - 1);  {remove trailing backslash}
  299.     if CompareStr(TempPath, FDirectory) <> 0 then { is it a dir change? }
  300.     begin
  301.       FDirectory := TempPath; { set new directory }
  302.       ChDir(FDirectory); { go there }
  303.       if TempPath[1] <> Drive then { check to see if we changed drives, too }
  304.         Drive := TempPath[1] { change drive/build list if needed }
  305.       else
  306.       begin
  307.         WalkTree(TempPath);
  308.         Change; { otherwise, we're done }
  309.       end;
  310.     end;
  311.   end;
  312. end;
  313.  
  314. procedure TDirectoryOutline.SetDrive(NewDrive: Char);
  315. begin
  316.   if UpCase(NewDrive) in ['A'..'Z'] then { disallow all but drive letters}
  317.   begin
  318.     if (FDrive = #0) or not SameLetter(NewDrive, FDrive) then { update if no current drive or change }
  319.     begin
  320.       FDrive := NewDrive;
  321.       ChDir(FDrive + ':');
  322.       GetDir(0, FDirectory); { always returns uppercase...yuck! }
  323.       FDirectory := ForceCase(FDirectory); { use correct case }
  324.       if not (csLoading in ComponentState) then BuildTree; { this ends up calling Change }
  325.     end;
  326.   end;
  327. end;
  328.  
  329. procedure TDirectoryOutline.SetTextCase(NewTextCase: TTextCase);
  330. var
  331.   CurrentPath: TFileName;
  332. begin
  333.   if NewTextCase <> FTextCase then
  334.   begin
  335.     FTextCase := NewTextCase;
  336.     AssignCaseProc;
  337.     if NewTextCase = tcAsIs then
  338.     begin
  339.       GetDir(0, CurrentPath);
  340.       FDrive := CurrentPath[1];
  341.       FDirectory := CurrentPath;
  342.     end;
  343.     if not (csLoading in ComponentState) then BuildTree;
  344.   end;
  345. end;
  346.  
  347. procedure TDirectoryOutline.WalkTree(const Dest: string);
  348. var
  349.   TempPath, NextDir: TFileName;
  350.   SlashPos: Integer;
  351.   TempItem: Longint;
  352.  
  353.   function GetChildNamed(const Name: string): Longint;
  354.   begin
  355.     Items[TempItem].Expanded := True;
  356.     Result := Items[TempItem].GetFirstChild;
  357.     while Result <> InvalidIndex do
  358.     begin
  359.       if Items[Result].Text = Name then Exit;
  360.       Result := Items[TempItem].GetNextChild(Result);
  361.     end;
  362.   end;
  363.  
  364. begin
  365.   TempItem := 1; { start at root }
  366.   TempPath := ForceCase(Dest);
  367.   if Pos(':', TempPath) > 0 then
  368.     TempPath := Copy(TempPath, Pos(':', TempPath) + 1, Length(TempPath));
  369.   if TempPath[1] = '\' then System.Delete(TempPath, 1, 1);
  370.   SlashPos := Pos('\', TempPath);
  371.   NextDir := TempPath;
  372.   while Length(TempPath) > 0 do
  373.   begin
  374.     SlashPos := Pos('\', TempPath);
  375.     if SlashPos > 0 then
  376.     begin
  377.       NextDir := Copy(TempPath, 1, SlashPos - 1);
  378.       TempPath := Copy(TempPath, SlashPos + 1, Length(TempPath));
  379.     end
  380.     else
  381.     begin
  382.       NextDir := TempPath;
  383.       TempPath := '';
  384.     end;
  385.     TempItem := GetChildNamed(NextDir);
  386.   end;
  387.   SelectedItem := TempItem;
  388. end;
  389.  
  390. function SameLetter(Letter1, Letter2: Char): Boolean;
  391. begin
  392.   Result := UpCase(Letter1) = UpCase(Letter2);
  393. end;
  394.  
  395. end.
  396.  
  397.